Image Compendium/Image Compendium.iso/viewer/dos/gifdoc.arc/RELACE.PAS

Pascal/Delphi Source File | 1988-04-13 | 5.4 KB | 180 lines

program RELACE;
uses CRT,DEGIF,ENGIF;

const YInc:array [1..5] of integer=(8,8,4,2,1);
      YLin:array [1..5] of integer=(0,4,2,1,0);

type Line=array [0..1023] of byte;

var  Lines:array [0..479] of ^Line;
     InFileName,OutFileName:string;
     YN,BlockType:char;
     Pass:byte;
     Bottom,Left,Right,Top,XCord,YCord:integer;
     InFile,OutFile:file of byte;
     LaceIt:boolean;
     PixCount:longint;

procedure Abort;
 begin
  close(OutFile); close(InFile); halt
 end;

{$F+}
function GetByte: byte;
 var B:byte;
 begin
  read(InFile,B);
  GetByte:=B
end;
{$F-}

{$F+}
procedure PutByte(Pix: integer);
var P:byte;
begin
 P:=lo(Pix);
 Lines[YCord]^[XCord]:=P;
 inc(PixCount);  inc(XCord);
 if XCord > Right
  then begin Write(YCord:5);  XCord:=Left;  inc(YCord,YInc[Pass]);
             if YCord > Bottom
              then begin inc(Pass); YCord:=YLin[Pass]+Top end
       end
end;
{$F-}

{$F+}
procedure WrtByte(I: integer);
 var B:byte;
 begin
  B:=lo(I);
  write(OutFile,B)
 end;
{$F-}

procedure AdjustImage;
 begin
  Left  := ImageLeft;
  Top   := ImageTop;
  Right := ImageWidth + Left -1;
  Bottom:= ImageHeight + Top -1;
  XCord:=Left;   YCord:=Top;
  if Interlaced then Pass:=1 else Pass:=5;
  Writeln;
  Writeln('Left  =',Left:6, '  Top=   ',Top:6);
  Writeln('Right =',Right:6  ,'  Bottom=',Bottom:6);
  if Interlaced
   then
    begin
     Write('Image is interlaced.  Do you want to un-lace it? [Y/n]');
     YN:=ReadKey;  writeln; LaceIt:=not(YN in ['y','Y',#13])
    end
   else
    begin
     Write('Image is not interlaced.  Do you want to lace it? [Y/n]');
     YN:=ReadKey;  writeln; LaceIt:=YN in ['y','Y',#13]
    end
 end;

procedure DisplayScrDes;
var AnsCh:char;
begin
 Writeln('Screen width =',ScreenWidth:5, '  Screen height   =',ScreenHeight:5);
 Writeln('Bits of color=',BitsOfColorPerPrimary:5,
         '  Number of colors=',NumberOfColors[Global]:5)
end;

begin
 AddrWrtByte:=@WrtByte;
 AddrGetByte:=@GetByte;
 AddrPutByte:=@PutByte;
 AssignCrt(output);Rewrite(OUTPUT);
 writeln('ReLace version 0.1 demo for DEGIF & ENGIF Turbo Pascal Unit');
 writeln('   Interlaces or De-interlaces and re-encodes GIF images');
 writeln('     Copyright (c) 1988 Cyborg Software Systems, Inc.');writeln;
 writeln('        GIF and "Graphics Interchange Format" are');
 writeln('       trademarks (tm) of CompuServe Incorporated');
 writeln('                  an H&R Block Company.');writeln;writeln;
 if paramcount<1
  then begin
        write('Enter GIF input file name:  '); readln(infilename);
       end
  else InFileName:=paramstr(1);
 if paramcount<2
  then begin
        write('Enter GIF output input file name:  '); readln(outfilename);
       end
  else OutFileName:=paramstr(2);
 if (length(InFileName)>0) and (length(OutFileName)>0) then
  begin
   assign(InFile,InFileName);
   {$I-}
   reset(InFile);
   if ioresult<>0
    then begin writeln('GIF datafile could not be found.'); halt end;
   assign(OutFile,OutFileName);
   rewrite(OutFile);
   if ioresult<>0
    then begin writeln('GIF output file could not be opened.'); halt end;
   CurMap:=Global;
   GetGIFSig;
   if GIFSig<>'GIF87a' then begin writeln('Invalid GIF ID'); Abort end;
   PutGIFSig;
   GetScrDes;
   if ScreenWidth>1024 then begin writeln('Screen too big'); Abort end;
   for YCord:=0 to ScreenHeight-1 do
    begin
     getmem(Lines[YCord],ScreenWidth);
     for XCord:=0 to ScreenWidth-1 do Lines[YCord]^[XCord]:=BackgrColorIndex
    end;
   DisplayScrDes;
   PutScrDes(ScreenWidth,ScreenHeight,BackgrColorIndex,
             BitsOfColorPerPrimary,BitsPerPixel[Global],
             MapExists[Global]);
   if MapExists[Global] then begin GetColorMap; PutColorMap end;
   while not EOF(InFile) Do
    begin
     BlockType:=chr(GetByte);
     case BlockType of
      ',':begin
           Writeln('Image separator "," found.');
           WrtByte(ord(','));
           GetImageDescription;
           AdjustImage;
           PutImageDescription(ImageLeft,ImageTop,ImageWidth,
                               ImageHeight,BitsPerPixel[Local],
                               MapExists[Local],LaceIt);
           if MapExists[Local]
            then begin CurMap:=Local; GetColorMap; PutColorMap end
            else CurMap:=Global;
           Writeln('Decoding...');PixCount:=0;
           if ExpandGIF <>0 then Halt;
           writeln; writeln(PixCount:10,' Pixels read.');
           writeln('Encoding...');
           if LaceIt then Pass:=1 else Pass:=5;
           YCord:=Top; PixCount:=0;
           repeat
            for XCord:=Left to Right
             do begin inc(PixCount); CompressGIF(Lines[YCord]^[XCord]) end;
            write(YCord:5);  inc(YCord,YInc[Pass]);
            if YCord > Bottom
             then begin inc(Pass); YCord:=YLin[Pass]+Top end
           until (LaceIt and (Pass>4)) or (Pass>5);
           EndCompress; writeln;
           writeln(PixCount:10,' Pixels written.');
          end;
      '!':begin
           WrtByte(ord(BlockType));
           SkipExtendBlock; Writeln('Expansion block "!" found.')
          end;
      ';':begin
           Writeln('GIF Terminator ";" found.');
           WrtByte(ord(';'));
           Sound(440);Delay(100);NoSound;Abort
          end;
     end;
    end;
  end;
end.